@@ -14,7 +14,7 @@ BrowserUk
- Suggesting the name 'lethal', which the module was
called during much of development.
-Jured Waalboer
+Juerd Waalboer
- Suggesting the name 'autodie'
Aristotle Pagaltzis
@@ -49,7 +49,7 @@ ikegami
of how it's been dressed.
Matt Kraai
- - Formatting fixess in diagnostics.
+ - Formatting fixes in diagnostics.
Darren Duncan
- Spotting omissions in user documentation.
@@ -88,3 +88,30 @@ Florian Ragwitz
- Help in tracking down string eval weirdness.
- Letting me cargo-cult code from B::Hooks::EndOfScope.
+Elliot Shank
+ - Integration into Perl::Critic
+
+Michael Schwern
+ - Finding a more-than-a-decade old bug in Fatal that caused
+ it to leak carp functions.
+ - Improvements to generated error messages.
+
+David Taylor
+ - Documentation fixes.
+
+Nick Cleaton
+ - Support for multi-arg open.
+
+Craig A. Berry
+ - VMS support.
+
+Jonathan Yu
+ - chmod support.
+ - Prevention of author tests failing if Sub::Identify not installed.
+
+Jerry D. Hedden
+ - Better test output, particularly when running as part of the
+ Perl core.
+
+Curtis Jewell
+ - Improvements to File::Copy tests under Windows.
@@ -1,5 +1,48 @@
Revision history for autodie
+2.10 Sat Feb 27 14:01:18 AUSEST 2010
+ * BUGFIX: Fatal and autodie no longer leak Carp functions
+ into the caller's namespace. Thanks to Schwern.
+
+ * TEST: Multi-arg open tests are really really skipped
+ under Windows now.
+
+ * DOCUMENTATION: Many more people are properly attributed
+ in the 'AUTHORS' file.
+
+2.09 Tue Feb 23 00:33:09 AUSEST 2010
+ * DOCS: Fixed documentation typo. RT #48575
+ Thanks to David Taylor.
+
+ * TEST: Tests involved multi-arg open are skipped
+ on Windows (where multi-arg pipe is not implemented).
+
+2.08 Mon Feb 8 14:24:26 AUSEST 2010
+ * BUGFIX: Addeds support for chmod. Many thanks to
+ Jonathan Yu for reporting this (RT #50423).
+
+ * BUGFIX: Multi-arg open is now supported by open.
+ Many thanks to Nick Cleaton for finding and fix this
+ bug. (RT #52427)
+
+ * BUILD: Updated to Module::Install 0.93
+
+2.07 Fri Jul 31 16:35:40 BST 2009
+
+ * FEATURE: Added ->eval_error to autodie::exception, which
+ stores the contents of $@ at the time autodie throws its
+ own exception. This is useful when dealing with modules
+ such as Text::Balanced which set (but do not throw)
+ $@ on error.
+
+ * TEST: Checking for flock() support no longer causes
+ test failures on older VMS sysstems. (RT #47812)
+ Thanks to Craig A. Berry for supplying a patch.
+
+ * TEST: hints.t tests should no longer cause bogus
+ failures relating to File::Copy on VMS and Windows
+ systems prior to Perl 5.10.2.
+
2.06 Tue Jul 7 00:01:37 AUSEST 2009
* BUG: Explicitly documented that autodie does NOT play
@@ -31,6 +31,7 @@ t/context_lexical.t
t/crickey.t
t/critic.t
t/dbmopen.t
+t/eval_error.t
t/exception_class.t
t/exceptions.t
t/exec.t
@@ -8,7 +8,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.91'
+generated_by: 'Module::Install version 0.93'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -27,4 +27,4 @@ resources:
bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie
license: http://dev.perl.org/licenses/
repository: http://github.com/pfenwick/autodie/tree/master
-version: 2.06
+version: 2.10
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.93';
}
# Suspend handler for "redefined" warnings
@@ -9,7 +9,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.93';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.93';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -7,7 +7,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.93';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -34,6 +34,17 @@ sub prompt {
}
}
+# Store a cleaned up version of the MakeMaker version,
+# since we need to behave differently in a variety of
+# ways based on the MM version.
+my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
+
+# If we are passed a param, do a "newer than" comparison.
+# Otherwise, just return the MakeMaker version.
+sub makemaker {
+ ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
+}
+
sub makemaker_args {
my $self = shift;
my $args = ( $self->{makemaker_args} ||= {} );
@@ -44,7 +55,7 @@ sub makemaker_args {
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
- my $self = sShift;
+ my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{name} = defined $args->{$name}
@@ -107,6 +118,9 @@ sub tests_recursive {
%test_dir = ();
require File::Find;
File::Find::find( \&_wanted_t, $dir );
+ if ( -d 'xt' and ($ENV{RELEASE_TESTING} or $self->author) ) {
+ File::Find::find( \&_wanted_t, 'xt' );
+ }
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
@@ -130,12 +144,13 @@ sub write {
# an underscore, even though its own version may contain one!
# Hence the funny regexp to get rid of it. See RT #35800
# for details.
- $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+ my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
+ $self->build_requires( 'ExtUtils::MakeMaker' => $v );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
- $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
}
@@ -145,49 +160,75 @@ sub write {
$args->{NAME} = $self->module_name || $self->name;
$args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
+ $DB::single = 1;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
+ } elsif ( -d 'xt' and ($self->author or $ENV{RELEASE_TESTING}) ) {
+ $args->{test} = {
+ TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
+ };
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
- $args->{NO_META} = 1;
+ if ( $self->makemaker(6.10) ) {
+ $args->{NO_META} = 1;
+ #$args->{NO_MYMETA} = 1;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
- # Merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
- map { @$_ }
+ map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
- ($self->configure_requires, $self->build_requires, $self->requires)
+ ($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
- # merge both kinds of requires into prereq_pm
+ # Merge both kinds of requires into BUILD_REQUIRES
+ my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
+ %$build_prereq = ( %$build_prereq,
+ map { @$_ } # flatten [module => version]
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires)
+ );
+
+ # Remove any reference to perl, BUILD_REQUIRES doesn't support it
+ delete $args->{BUILD_REQUIRES}->{perl};
+
+ # Delete bundled dists from prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
foreach my $bundle (@{ $self->bundles }) {
my ($file, $dir) = @$bundle;
push @$subdirs, $dir if -d $dir;
- delete $prereq->{$file};
+ delete $build_prereq->{$file}; #Delete from build prereqs only
}
}
+ unless ( $self->makemaker('6.55_03') ) {
+ %$prereq = (%$prereq,%$build_prereq);
+ delete $args->{BUILD_REQUIRES};
+ }
+
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
+
+ if ( $self->makemaker(6.48) ) {
+ $args->{MIN_PERL_VERSION} = $perl_version;
+ }
}
$args->{INSTALLDIRS} = $self->installdirs;
@@ -265,4 +306,4 @@ sub postamble {
__END__
-#line 394
+#line 435
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.93';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -230,6 +230,8 @@ sub all_from {
die("The path '$file' does not exist, or is not a file");
}
+ $self->{values}{all_from} = $file;
+
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
@@ -385,11 +387,10 @@ sub name_from {
}
}
-sub perl_version_from {
- my $self = shift;
+sub _extract_perl_version {
if (
- Module::Install::_read($_[0]) =~ m/
- ^
+ $_[0] =~ m/
+ ^\s*
(?:use|require) \s*
v?
([\d_\.]+)
@@ -398,6 +399,16 @@ sub perl_version_from {
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
+ return $perl_version;
+ } else {
+ return;
+ }
+}
+
+sub perl_version_from {
+ my $self = shift;
+ my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
+ if ($perl_version) {
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
@@ -425,13 +436,12 @@ sub author_from {
}
}
-sub license_from {
- my $self = shift;
+sub _extract_license {
if (
- Module::Install::_read($_[0]) =~ m/
+ $_[0] =~ m/
(
=head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
+ (?:licen[cs]e|licensing|copyrights?|legal)\b
.*?
)
(=head\\d.*|=cut.*|)
@@ -439,7 +449,9 @@ sub license_from {
/ixms ) {
my $license_text = $1;
my @phrases = (
- 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1,
+ 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'Artistic and GPL' => 'perl', 1,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
@@ -456,20 +468,32 @@ sub license_from {
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
+ $pattern =~ s#\s+#\\s+#gs;
if ( $license_text =~ /\b$pattern\b/i ) {
- $self->license($license);
- return 1;
+ return $license;
}
}
+ } else {
+ return;
}
+}
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
+sub license_from {
+ my $self = shift;
+ if (my $license=_extract_license(Module::Install::_read($_[0]))) {
+ $self->license($license);
+ } else {
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+ }
}
sub _extract_bugtracker {
- my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
+ my @links = $_[0] =~ m#L<(
+ \Qhttp://rt.cpan.org/\E[^>]+|
+ \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
+ \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
+ )>#gx;
my %links;
@links{@links}=();
@links=keys %links;
@@ -485,7 +509,7 @@ sub bugtracker_from {
return 0;
}
if ( @links > 1 ) {
- warn "Found more than on rt.cpan.org link in $_[0]\n";
+ warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.93';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';;
+ $VERSION = '0.93';;
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -28,7 +28,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.91';
+ $VERSION = '0.93';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -348,17 +348,24 @@ sub _caller {
return $call;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
- if ( $] >= 5.006 ) {
- open( FH, '<', $_[0] ) or die "open($_[0]): $!";
- } else {
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
- }
+ open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_NEW
+sub _read {
+ local *FH;
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
+END_OLD
sub _readperl {
my $string = Module::Install::_read($_[0]);
@@ -379,18 +386,26 @@ sub _readpod {
return $string;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
- if ( $] >= 5.006 ) {
- open( FH, '>', $_[0] ) or die "open($_[0]): $!";
- } else {
- open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
}
+ close FH or die "close($_[0]): $!";
+}
+END_NEW
+sub _write {
+ local *FH;
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
+END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
@@ -427,4 +442,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2009 Adam Kennedy.
+# Copyright 2008 - 2010 Adam Kennedy.
@@ -5,6 +5,7 @@ use Carp;
use strict;
use warnings;
use Tie::RefHash; # To cache subroutine refs
+use Config;
use constant PERL510 => ( $] >= 5.010 );
@@ -39,7 +40,7 @@ use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supporte
use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
# All the Fatal/autodie modules share the same version number.
-our $VERSION = '2.06';
+our $VERSION = '2.10';
our $Debug ||= 0;
@@ -52,6 +53,10 @@ our %_EWOULDBLOCK = (
MSWin32 => 33,
);
+# the linux parisc port has separate EAGAIN and EWOULDBLOCK,
+# and the kernel returns EAGAIN
+my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0;
+
# We have some tags that can be passed in for use with import.
# These are all assumed to be CORE::
@@ -60,7 +65,7 @@ my %TAGS = (
read seek sysread syswrite sysseek )],
':dbm' => [qw(dbmopen dbmclose)],
':file' => [qw(open close flock sysopen fcntl fileno binmode
- ioctl truncate)],
+ ioctl truncate chmod)],
':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
symlink rmdir readlink umask)],
':ipc' => [qw(:msg :semaphore :shm pipe)],
@@ -84,25 +89,37 @@ my %TAGS = (
':default' => [qw(:io :threads)],
+ # Everything in v2.07 and brefore. This was :default less chmod.
+ ':v207' => [qw(:threads :dbm :filesys :ipc :socket read seek sysread
+ syswrite sysseek open close flock sysopen fcntl fileno
+ binmode ioctl truncate)],
+
# Version specific tags. These allow someone to specify
# use autodie qw(:1.994) and know exactly what they'll get.
- ':1.994' => [qw(:default)],
- ':1.995' => [qw(:default)],
- ':1.996' => [qw(:default)],
- ':1.997' => [qw(:default)],
- ':1.998' => [qw(:default)],
- ':1.999' => [qw(:default)],
- ':1.999_01' => [qw(:default)],
- ':2.00' => [qw(:default)],
- ':2.01' => [qw(:default)],
- ':2.02' => [qw(:default)],
- ':2.03' => [qw(:default)],
- ':2.04' => [qw(:default)],
- ':2.05' => [qw(:default)],
- ':2.06' => [qw(:default)],
+ ':1.994' => [qw(:v207)],
+ ':1.995' => [qw(:v207)],
+ ':1.996' => [qw(:v207)],
+ ':1.997' => [qw(:v207)],
+ ':1.998' => [qw(:v207)],
+ ':1.999' => [qw(:v207)],
+ ':1.999_01' => [qw(:v207)],
+ ':2.00' => [qw(:v207)],
+ ':2.01' => [qw(:v207)],
+ ':2.02' => [qw(:v207)],
+ ':2.03' => [qw(:v207)],
+ ':2.04' => [qw(:v207)],
+ ':2.05' => [qw(:v207)],
+ ':2.06' => [qw(:v207)],
+ ':2.06_01' => [qw(:v207)],
+ ':2.07' => [qw(:v207)], # Last release without chmod
+ ':2.08' => [qw(:default)],
+ ':2.09' => [qw(:default)],
+ ':2.10' => [qw(:default)],
);
+# chmod was only introduced in 2.07
+
$TAGS{':all'} = [ keys %TAGS ];
# This hash contains subroutines for which we should
@@ -167,6 +184,7 @@ my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie'
sub import {
my $class = shift(@_);
+ my @original_args = @_;
my $void = 0;
my $lexical = 0;
my $insist_hints = 0;
@@ -305,6 +323,16 @@ sub import {
$class->_install_subs($pkg, \%unload_later);
}));
+ # To allow others to determine when autodie was in scope,
+ # and with what arguments, we also set a %^H hint which
+ # is how we were called.
+
+ # This feature should be considered EXPERIMENTAL, and
+ # may change without notice. Please e-mail pjf@cpan.org
+ # if you're actually using it.
+
+ $^H{autodie} = "$PACKAGE @original_args";
+
}
return;
@@ -448,8 +476,10 @@ sub unimport {
while (my $item = shift @to_process) {
if ($item =~ /^:/) {
+ # Expand :tags
push(@to_process, @{$TAGS{$item}} );
- } else {
+ }
+ else {
push(@taglist, "CORE::$item");
}
}
@@ -519,7 +549,17 @@ sub _write_invocation {
@argv = @{shift @argvs};
$n = shift @argv;
- push @out, "${else}if (\@_ == $n) {\n";
+ my $condition = "\@_ == $n";
+
+ if (@argv and $argv[-1] =~ /#_/) {
+ # This argv ends with '@' in the prototype, so it matches
+ # any number of args >= the number of expressions in the
+ # argv.
+ $condition = "\@_ >= $n";
+ }
+
+ push @out, "${else}if ($condition) {\n";
+
$else = "\t} els";
push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
@@ -593,11 +633,11 @@ sub _one_invocation {
if ($void) {
return qq/return (defined wantarray)?$call(@argv):
- $call(@argv) || croak "Can't $name(\@_)/ .
- ($core ? ': $!' : ', \$! is \"$!\"') . '"'
+ $call(@argv) || Carp::croak("Can't $name(\@_)/ .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '")'
} else {
- return qq{return $call(@argv) || croak "Can't $name(\@_)} .
- ($core ? ': $!' : ', \$! is \"$!\"') . '"';
+ return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '")';
}
}
@@ -698,6 +738,7 @@ sub _one_invocation {
function => q{$human_sub_name}, args => [ @argv ],
pragma => q{$class}, errno => \$!,
context => \$context, return => \$retval,
+ eval_error => \$@
)
};
@@ -718,6 +759,11 @@ sub _one_invocation {
my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
|| $_EWOULDBLOCK{$^O}
|| _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
+ my $EAGAIN = $EWOULDBLOCK;
+ if ($try_EAGAIN) {
+ $EAGAIN = eval { POSIX::EAGAIN(); }
+ || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system.");
+ }
require Fcntl; # For Fcntl::LOCK_NB
@@ -733,7 +779,9 @@ sub _one_invocation {
# If we failed, but we're using LOCK_NB and
# returned EWOULDBLOCK, it's not a real error.
- if (\$_[1] & Fcntl::LOCK_NB() and \$! == $EWOULDBLOCK ) {
+ if (\$_[1] & Fcntl::LOCK_NB() and
+ (\$! == $EWOULDBLOCK or
+ ($try_EAGAIN and \$! == $EAGAIN ))) {
return \$retval;
}
@@ -1051,7 +1099,7 @@ sub _make_fatal {
{
local $@;
- $code = eval("package $pkg; use Carp; $code"); ## no critic
+ $code = eval("package $pkg; require Carp; $code"); ## no critic
$E = $@;
}
@@ -1129,7 +1177,7 @@ sub _make_fatal {
>;
}
- $leak_guard .= qq< croak "Internal error in Fatal/autodie. Leak-guard failure"; } >;
+ $leak_guard .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >;
# warn "$leak_guard\n";
@@ -5,7 +5,7 @@ use warnings;
use base 'autodie::exception';
use Carp qw(croak);
-our $VERSION = '2.06';
+our $VERSION = '2.10';
my $PACKAGE = __PACKAGE__;
@@ -14,7 +14,7 @@ use overload
use if ($] >= 5.010), overload => '~~' => "matches";
-our $VERSION = '2.06';
+our $VERSION = '2.10';
my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys.
@@ -170,6 +170,18 @@ set on failure.
sub errno { return $_[0]->{$PACKAGE}{errno}; }
+=head3 eval_error
+
+ my $old_eval_error = $E->eval_error;
+
+The contents of C<$@> immediately after autodie triggered an
+exception. This may be useful when dealing with modules such
+as L<Text::Balanced> that set (but do not throw) C<$@> on error.
+
+=cut
+
+sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; }
+
=head3 matches
if ( $e->matches('open') ) { ... }
@@ -698,6 +710,7 @@ sub _init {
$this->{$PACKAGE}{context} = $args{context};
$this->{$PACKAGE}{return} = $args{return};
+ $this->{$PACKAGE}{eval_error} = $args{eval_error};
$this->{$PACKAGE}{args} = $args{args} || [];
$this->{$PACKAGE}{function}= $args{function} or
@@ -5,7 +5,7 @@ use warnings;
use constant PERL58 => ( $] < 5.009 );
-our $VERSION = '2.06';
+our $VERSION = '2.10';
=head1 NAME
@@ -8,7 +8,7 @@ our @ISA = qw(Fatal);
our $VERSION;
BEGIN {
- $VERSION = '2.06';
+ $VERSION = '2.10';
}
use constant ERROR_WRONG_FATAL => q{
@@ -264,7 +264,7 @@ C<system> and C<exec> with:
=head2 flock
It is not considered an error for C<flock> to return false if it fails
-to an C<EWOULDBLOCK> (or equivalent) condition. This means one can
+due to an C<EWOULDBLOCK> (or equivalent) condition. This means one can
still use the common convention of testing the return value of
C<flock> when called with the C<LOCK_NB> option:
@@ -373,9 +373,6 @@ Under Perl 5.8 only, C<autodie> I<does not> propagate into string C<eval>
statements, although it can be explicitly enabled inside a string
C<eval>.
-Under Perl 5.10 only, C<autodie> I<does not> operate correctly when
-used inside a string C<eval>.
-
Under Perl 5.10 only, using a string eval when C<autodie> is in
effect can cause the autodie behaviour to leak into the surrounding
scope. This can be worked around by using a C<no autodie> at the
@@ -0,0 +1,20 @@
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+use Test::More 'no_plan';
+use autodie;
+
+use constant NO_SUCH_FILE => 'this_file_had_better_not_exist';
+use constant MAGIC_STRING => 'xyzzy';
+
+# Opening an eval clears $@, so it's important that we set it
+# inside the eval block to see if it's successfully captured.
+
+eval {
+ $@ = MAGIC_STRING;
+ is($@, MAGIC_STRING, 'Sanity check on start conditions');
+ open(my $fh, '<', NO_SUCH_FILE);
+};
+
+isa_ok($@, 'autodie::exception');
+is($@->eval_error, MAGIC_STRING, 'Previous $@ should be captured');
@@ -2,7 +2,8 @@
use strict;
use Test::More;
use Fcntl qw(:flock);
-use POSIX qw(EWOULDBLOCK);
+use POSIX qw(EWOULDBLOCK EAGAIN);
+use Config;
require Fatal;
@@ -10,6 +11,9 @@ my $EWOULDBLOCK = eval { EWOULDBLOCK() }
|| $Fatal::_EWOULDBLOCK{$^O}
|| plan skip_all => "EWOULDBLOCK not defined on this system";
+my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0;
+my $EAGAIN = eval { EAGAIN() };
+
my ($self_fh, $self_fh2);
eval {
@@ -23,7 +27,7 @@ if ($@) {
plan skip_all => "Cannot lock this test on this system.";
}
-my $flock_return = flock($self_fh, LOCK_EX | LOCK_NB);
+my $flock_return = eval { flock($self_fh, LOCK_EX | LOCK_NB); };
if (not $flock_return) {
plan skip_all => "flock on my own test not supported on this system.";
@@ -55,7 +59,11 @@ eval {
$return = flock($self_fh2, LOCK_EX | LOCK_NB);
};
-is($!+0, $EWOULDBLOCK, "Double-flocking should be EWOULDBLOCK");
+if (!$try_EAGAIN) {
+ is($!+0, $EWOULDBLOCK, "Double-flocking should be EWOULDBLOCK");
+} else {
+ ok($!+0 == $EWOULDBLOCK || $!+0 == $EAGAIN, "Double-flocking should be EWOULDBLOCK or EAGAIN");
+}
ok(!$return, "flocking a file twice should fail");
is($@, "", "Non-blocking flock should not fail on EWOULDBLOCK");
@@ -15,6 +15,16 @@ use constant NO_SUCH_FILE2 => "this_file_had_better_not_exist_xyzzy";
use constant PERL510 => ( $] >= 5.0100 );
use constant PERL5101 => ( $] >= 5.0101 );
+use constant PERL5102 => ( $] >= 5.0102 );
+
+# File::Copy states that all subroutines return '0' on failure.
+# However both Windows and VMS may return other false values
+# (notably empty-string) on failure. This constant indicates
+# whether we should skip some tests because the return values
+# from File::Copy may not be what's in the documentation.
+
+use constant WEIRDO_FILE_COPY =>
+ ( ! PERL5102 and ( $^O eq "MSWin32" or $^O eq "VMS" ));
use Hints_test qw(
fail_on_empty fail_on_false fail_on_undef
@@ -63,8 +73,8 @@ isa_ok($@, "autodie::exception");
is($@->function, "File::Copy::copy", "Function should be original name");
SKIP: {
- skip("File::Copy is weird on Win32 before 5.10.1", 1)
- if ( ! PERL5101 and $^O eq "MSWin32" );
+ skip("File::Copy is weird on Win32/VMS before 5.10.1", 1)
+ if WEIRDO_FILE_COPY;
is($@->return, 0, "File::Copy returns zero on failure");
}
@@ -85,8 +95,8 @@ isa_ok($@, "autodie::exception");
is($@->function, "File::Copy::copy", "Function should be original name");
SKIP: {
- skip("File::Copy is weird on Win32 before 5.10.1", 1)
- if ( ! PERL5101 and $^O eq "MSWin32" );
+ skip("File::Copy is weird on Win32/VMS before 5.10.1", 1)
+ if WEIRDO_FILE_COPY;
is_deeply($@->return, [0], "File::Copy returns zero on failure");
}
@@ -33,7 +33,7 @@ no warnings 'qw';
# Technically the outputted code varies from the classical Fatal.
# However the changes are mostly whitespace. Those that aren't are
-# improvements to error messages.
+# improvements to error messages or bug fixes.
my @write_invocation_calls = (
[
@@ -43,9 +43,9 @@ my @write_invocation_calls = (
[ 3, qw($_[0] $_[1] @_[2..$#_])]
],
q{ if (@_ == 1) {
-return CORE::open($_[0]) || croak "Can't open(@_): $!" } elsif (@_ == 2) {
-return CORE::open($_[0], $_[1]) || croak "Can't open(@_): $!" } elsif (@_ == 3) {
-return CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"
+return CORE::open($_[0]) || Carp::croak("Can't open(@_): $!") } elsif (@_ == 2) {
+return CORE::open($_[0], $_[1]) || Carp::croak("Can't open(@_): $!") } elsif (@_ >= 3) {
+return CORE::open($_[0], $_[1], @_[2..$#_]) || Carp::croak("Can't open(@_): $!")
}
die "Internal error: open(@_): Do not expect to get ", scalar(@_), " arguments";
}
@@ -62,12 +62,12 @@ my @one_invocation_calls = (
# Core # Call # Name # Void # Args
[
[ 1, 'CORE::open', 'open', 0, qw($_[0] $_[1] @_[2..$#_]) ],
- q{return CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"},
+ q{return CORE::open($_[0], $_[1], @_[2..$#_]) || Carp::croak("Can't open(@_): $!")},
],
[
[ 1, 'CORE::open', 'open', 1, qw($_[0] $_[1] @_[2..$#_]) ],
q{return (defined wantarray)?CORE::open($_[0], $_[1], @_[2..$#_]):
- CORE::open($_[0], $_[1], @_[2..$#_]) || croak "Can't open(@_): $!"},
+ CORE::open($_[0], $_[1], @_[2..$#_]) || Carp::croak("Can't open(@_): $!")},
],
);
@@ -47,3 +47,32 @@ eval {
isa_ok($@, 'autodie::exception');
like( $@, qr/at \S+ line \d+/, "At least one mention");
unlike($@, qr/at \S+ line \d+\s+at \S+ line \d+/, "...but not too mentions");
+
+# RT 52427. Piped open can have any many args.
+
+# Sniff to see if we can run 'true' on this system. Changes we can't
+# on non-Unix systems.
+
+eval {
+ use autodie;
+
+ die "Windows does not support multi-arg pipe" if $^O eq "MSWin32";
+
+ open(my $fh, '-|', "true");
+};
+
+SKIP: {
+ skip('true command or list pipe not available on this system', 1) if $@;
+
+ eval {
+ use autodie;
+
+ my $fh;
+ open $fh, "-|", "true";
+ open $fh, "-|", "true", "foo";
+ open $fh, "-|", "true", "foo", "bar";
+ open $fh, "-|", "true", "foo", "bar", "baz";
+ };
+
+ is $@, '', "multi arg piped open does not fail";
+}
@@ -1,7 +1,8 @@
#!/usr/bin/perl -w
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 5;
+use constant NO_SUCH_FILE => 'THIS_FILE_HAD_BETTER_NOT_EXIST';
eval {
use autodie qw(:1.994);
@@ -11,7 +12,6 @@ eval {
isa_ok($@, 'autodie::exception', "Basic version tags work");
-
# Expanding :1.00 should fail, there was no autodie :1.00
eval { my $foo = autodie->_expand_tag(":1.00"); };
@@ -24,3 +24,21 @@ eval { my $foo = autodie->_expand_tag(":$version"); };
is($@,"","Expanding :$version should succeed");
+eval {
+ use autodie qw(:2.07);
+
+ # 2.07 didn't support chmod. This shouldn't throw an
+ # exception.
+
+ chmod(0644,NO_SUCH_FILE);
+};
+
+is($@,"","chmod wasn't supported in 2.07");
+
+eval {
+ use autodie;
+
+ chmod(0644,NO_SUCH_FILE);
+};
+
+isa_ok($@, 'autodie::exception', 'Our current version supports chmod');